Ap pendix A 
Snftwarp Modules 



Module Title 



About 



Number of 
Pa?es 



1 page ■ 



ImageDisplay 3 pages 

RefDisplay ^ pages 

SampleLocator ^ pages 

Sdimain ^ pages 

ShadeData ^P^S^^ 

SplashScreen ^ pages 
ToothObject 6 pages 



unit About; 
interface 

uses Windows, Classes, Graphics, Forias, Controls, StdCtrl; 
Buttons, ExtCtrls; 

type 

TAboutBox = class (TForra) 

Panell: TPanel; 

OKButton: TButton; 

Programlcon: TImage; 

ProductName: TLabel; 

Version: TLabel; 

Copyright: TLabel; 

Comment s : T Labe 1 ; 
private 

{ Private declarations } 
public 

{ Public declarations } 
end; 

var 

AboutBox: TAboutBox; 
implementation 
{$R *.DFM) 
end. 
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unit ImageDisplay; 

interface 

uses 

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs 
TMultiP, ExtCtrls; 

type 

TfrmlmageDisplay = class (TForm) 

pnl Image: TPanel; 

pmilmage: TPMult i Image; 

procedure FormCr eat e (Sender: TObject); 

procedure pmilmagePaint (Sender : TObject); 
private 

{ Private declarations } 

RefA : TRect; 

RefR : integer; 

RefC : integer; 

SampleA : TRect; 

SarapleR : integer; 

SampleC : integer; 

DisplayGrid : boolean; 

procedure DrawGrid (Area : TRect; Rows, Columns : integer) ; 
procedure DrawGrids; 
public 

{ Public declarations } 

procedure DefineGrids (RefArea: TRect; 

RefRows : integer; 

RefCols : integer; 

SampleArea : TRect; 

SampleRows : integer; 

SampleCols : integer) ; 

procedure HideGrid; 
end; 

var 

f rmlmageDisplay: TfrmlmageDisplay; 
implementation 
($R *.DFM} 

procedure TfrmlmageDisplay. DrawGrid (Area : TRect; Rows, Columns : integer) 
var 

Spacing : real; 
index : integer; 
ScaleX : real; 
ScaleY : real; 

Left, Right, Top, Bottom : integer; 
begin 

ScaleX := pmilmage. Width/640; 
ScaleY := pmilmage. Height/480; 
Left := Round (Are a. Left * ScaleX); 
Right := Round (Area . Right * ScaleX); 
Top := Round (Area . Top * ScaleY); 
Bottom := Round (Area. Bottom * ScaleY); 
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with pmilmage . Canvas do 
begin 
: moveto (Lef Top) ; 

lineto(Left, Bottom); 

lineto {Right, Bottom); 

lineto(Right, Top); 

lineto (Left, Top); 

if Rows > 1 then 
begin 

Spacing := (Bottom - Top) / Rows; 
for index := 1 to Rows - 1 do 
begin 

moveto (Lef t+1. Top + trunc (Spacing * index)); 
lineto (Right-1, Top + trunc (Spacing * index)); 
end; 
end; 

if Columns > 1 then 
begin 

Spacing := (Right - left) / Columns; 
for index := 1 to Columns - 1 do 
begin 

moveto(Left + trunc (Spacing * index), Top+1); 
lineto(Left + trunc (Spacing * index), Bottom-1) ; 
end; 
end; 
end; 

end; // DrawGrid 

procedure Tf rmlmageDisplay. DrawGrids; 
begin 

SetR0P2 (pmilmage. Canvas. Handle, R2_N0T) ; 

if DisplayGrid then 
begin 

DrawGrid (Ref A, RefR, RefC) ; 
DrawGrid (SarapleA, SampleR, SampleC) ; 
end; 

end; // DrawGrids 



procedure TfrmlmageDisplay.FormCreate (Sender: TObject); 
begin 

DisplayGrid := false; 
end; 

procedure TfrmlmageDisplay.DefineGrids (Ref Area: TRect; 

Ref Rows : integer; 
RefCols : integer; 
SampleArea : TRect; 
SampleRows : integer; 
SarapleCols ; integer) 

begin 

Ref A := Ref Area; 
RefR := Ref Rows; 
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RefC := RefCols; 
SampleA := SampleArea; 
SarapleR := SampleRows; 
SampleC := SampleCols; 
DisplayGrid := true; 
pmilmage . Repaint ; 
end; 

procedure Tf rmlmageDisplay . HideGrid; 
begin 

DisplayGrid := false; 
Repaint; 
end; 

procedure Tf rmlmageDisplay. ptnilraagePaint (Sender: TObject) 
begin 

DrawGrids; 
end; 

end. 
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unit RefDisplay; 



interface 
uses 

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
Grids, ShadeData, ComCtrls, StdCtrls, ExtCtrls; 

type 

TfrmReferenceDisplay = class (TForm) 
Panell: TPanel; 
sgAnalysis: TStringGrid; 
Panel2: TPanel; 
edGridCol: TEdit; 
udGridCol: TUpDown; 
edGridRow: TEdit; 
udGridRow: TUpDown; 
Labell: TLabel; 
Label 2: TLabel; 
Label3: TLabel; 

procedure FormCreate (Sender : TObject) ; 

procedure InsertShadeData (Shade : TShadeColours) ; 

procedure edGridColChange (Sender : TObject); 

procedure LoadShades (Shades : TShadeReferences) ; 

procedure edGridRowChange (Sender : TObject); 
private 

{ Private declarations } 

Rowlnsertlndex : integer; 

DisplayRow : integer; 

DisplayColumn : integer; 

DisplayShades : TShadeReferences; 

procedure ShowShades; 
public 

{ Public declarations ) 
end; 

var 

frmReferenceDi splay: TfrmReferenceDisplay; 

implementation 

{$R *.DFM} 

const 

TitleRow = 0; 
NameColumn =0; 
RedColumn = NameColumn +1; 
GreenColumn = RedColumn + 1; 
BlueColumn = GreenColumn + 1; 
VariationColumn = BlueColumn + 1; 
RedMaxColumn = VariationColumn + 1; 
RedMinColumn = RedMaxColumn + 1; 
GreenMaxColumn = RedMinColumn + 1; 
GreenMinColumn = GreenMaxColumn +1; 
BlueMaxColuran = GreenMinColxamn + 1; 
BlueMinColumn = BlueMaxColumn + 1; 
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Precision = 6; 
Digits = 4; 



procedure TfrmRef erenceDisplay. FormCreate (Sender : TObject) ; 
begin 

{ Configure the Grid to Display the Reference Set } 
Display Column := GridWidth div 2; 
DisplayRow := GridHeight div 2; 



udGridCol.Min := 1; 
udGridCol.Max := GridWidth; 

udGridRow.Min := 1; 
udGridRow.Max := GridHeight; 

udGridRow. Position := DisplayRow; 
udGridCol. Position := DisplayColumn; 

edGridCol . Text := IntToStr (DisplayColumn) ; 
edGridRow. Text := IntToStr (DisplayRow) ; 

sgAnalysis,.ColCount := 11; 

sgAnalysis . RowCount := 17; // may change 

Rowlnsertlndex := TitleRow +1; 

sgAnalysis .Cells [NameColumn, TitleRow] := 'Shade'; 
sgAnalysis -Cells [RedColumn, TitleRow) := 'Red'; 
sgAnalysis .Cells [GreenCclumn, TitleRow] := 'Green'; 
sgAnalysis .Cells [BlueColumn, TitleRow] := 'Blue'; 
sgAnalysis .Cells (VariationColumn, TitleRow] := 'Variation'; 
sgAnalysis .Cells (RedMaxColumn, TitleRow] := 'Max Red'; 
sgAnalysis. Cells (GreenMaxColumn, TitleRow] := 'Max Green'; 
sgAnalysis .Cells (BlueMaxColuran, TitleRow] := 'Max Blue'; 
sgAnalysis. Cells (RedMinColumn, TitleRow] := 'MinRed'; 
sgAnalysis . Cells [GreenMinColiomn, TitleRow] := 'Min Green'; 
sgAnalysis .Cells [BlueMinColumn, TitleRow] := 'Min Blue'; 

DisplayShades := TShadeReferences .Create; 
end; 



procedure TfrmRef erenceDisplay. InsertShadeData (Shade : TShadeColours) ; 
var 

Variation : real; 
begin 

with Shade . GridColours I DisplayColumn, DisplayRow] do 

begin « • 

sgAnalysis. Cells [NameColumn, Rowlnsertlndex] := Shade. Name; 

sgAnalysis. Cells [RedColumn, Rowlnsertlndex) := FloatToStrF (Red, ff Fixed, 
Precision, Digits) ; 

sgAnalysis. Cells [GreenColumn, Rowlnsertlndex] := FloatToStrF (Green, ff Fixed, 
Precision, Digits) ; 

sgAnalysis .Cells [BlueColumn, Rowlnsertlndex] := FloatToStrF (Blue, ff Fixed, 
Precision, Digits) ; 

sgAnalysis. Cells [RedMaxColuran, Rowlnsertlndex] := FloatToStrF (RedMax, 
ff Fixed, Precision, Digits); 
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sgAnalysis. Cells [GreenMaxColumn, Rowlnsertlndex] := FloatToStrF {GreenMax, 
ffFixed, Precision, Digits); 

sgAnalysis .Cells [BlueMaxColumn, Rowlnsertlndex] := FloatToStrF (BlueMax, 
ffFixed, Precision, Digits) ; 

sgAnalysis. Cells [RedMinColumn, Rowlnsertlndex] := FloatToStrF (RedMin, 
ffFixed, Precision, Digits), - 

sgAnalysis. Cells [GreenMinColumn, Rowlnsertlndex] := FloatToStrF (GreenMin, 
ffFixed, Precision, Digits) ; 

sgAnalysis -Cells [BlueMinColumn, Rowlnsertlndex] := FloatToStrF (BlueMin, 
ffFixed, Precision, Digits) ; 

Variation := (RedMax - RedMin) + {GreenMax - GreenMin) + (BlueMax - 
BlueMin) ; 

sgAnalysis. Cells [VariationColuitm, Rowlnsertlndex] := FloatToStrF (Variation, 
ffFixed, Precision, Digits); 
end; 

inc (Rowlnsertlndex) ; 
end; 

procedure Tf rmRef erenceDisplay. ShowShades; 
var 

Shadelndex : integer; 
CurrentShade : TShadeColours; 
begin 

Rowlnsertlndex := TitleRow + 1; 

for Shadelndex := 0 to DisplayShades . ShadeList .Count - 1 do 
begin 

CurrentShade := DisplayShades. ShadeList. Items [Shadelndex] ; 
InsertShadeData (CurrentShade) ; 
end; 
end; 

procedure Tf rmRef erenceDisplay . LoadShades (Shades : TShadeReferences) ; 
var 

IDisplayRow : integer; 
begin 

( First Clear Old list ) 

if DisplayShades. ShadeList. Count > 0 then 

for IDisplayRow := 1 to DisplayShades. ShadeList. Count do 
sgAnalysis. Rows [IDisplayRow] .Clear; 

//DisplayShades . Free; 

DisplayShades := Shades; 

sgAnalysis .RowCount := Shades. ShadeList, Count + 1; 
ShowShades; 
end; 

procedure Tf rmRef erenceDisplay. edGridColChange {Sender: TObject) ; 
begin 

if Visible then 

begin 

DisplayColumn := StrToInt (edGridCol.Text) ; 
ShowShades; 
end; 
end; 

procedure Tf rmRef erenceDisplay. edGridRowChange (Sender: TObject) ; 
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begin 

if Visible then 
begin 

DisplayRow := StrToInt (edGridRow.Text) ; 
ShowShades ; 
end; 
end; 

end. 
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unit SampleLocator; 



interface 
uses 

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
TMultiP, ExtCtrls, StdCtrls; 

type 

TfrmSampleLocator = class (TForm) 

Panell: TPanel; 
J pmilmage: TPMultilmage; 
J OpenDialog: TOpenDialog; 

btnLoadS ample: TButton; 

edXPos: TEdit; 
□ Label 1: TLabel; 

edYPos: TEdit; 
f\ Label2: TLabel; 
p! rgLocation: TRadioGroup; 

Panel2: TPanel; 

Labels : TLabel; 
=! Label 4: TLabel; 
^ edRefX: TEdit; 
U Labels: TLabel; 
7 edRefY: TEdit; 
J Label6: TLabel; 
i: edSampleX: TEdit; 

Label7: TLabel; 

edSampleY: TEdit; 

Labels : TLabel; 

btnSave: TButton; 

btnCancei: TButton; 

procedure pmilmageMouseMove (Sender : TObject; Shift: TShiftState; X, 
Y: Integer) ; 

procedure ForraCreate (Sender : TObject); 

procedure btnSaveClick (Sender : TObject); 

procedure btnLoadSampleClick (Sender : TObject); 

procedure pmilmageClick (Sender : TObject); 

procedure FormShow (Sender: TObject); 

procedure btnCancelClick (Sender : TObject); 
private 

{ Private declarations } 
public 

{ Public declarations } 

ReferenceLocation : TPoint; 

SampleLocation : TPoint; 



end; 
var 

f rmSampleLocator : TfrmSampleLocator; 
implementation 
{$R *.DFM} 
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uses 

SDIMain, IniFiles; 



procedure TfrmSampleLocator.prailmageMouseMove (Sender: TObject; 

Shift: TShiftState; X, Y: Integer); 
begin 

edXPos.Text := IntToStr (X) ; 
edYPos.Text := IntToStr(Y); 
end; 

C^jrocedure TfrmSampleLocator . FormCreate (Sender: TObject); 

iCvar 

£\ IniFile : TIniFile; 

pibegLn 

jTi { Load The Saved Sample Location From Ini File } 
f==i { Set Default for now } 
Jfi ReferenceLocation := Point (170, 40); 
SampleLocation := Point (300, 160); 

i;^ if FileExists (frmShadeAnalyzer . DiskDrive + 'AnalyseN' + IniFileName) then 
begin 

%i try 

yy IniFile := TIniFile. Create (frmShadeAnalyzer. DiskDrive + 'Analyse\' + 

ClniFileName) ; 

with ReferenceLocation do 
begin 

X := StrToInt (IniFile. ReadString (IniRef erenceSection, IniRefX, 'ERROR')); 

Y := StrToInt (IniFile. ReadString (IniRef erenceSection, IniRef Y, 'ERROR')); 
end; 

with SampleLocation do 
begin 

X := StrToInt (IniFile. ReadString (IniSampleSection, IniSampleX, 'ERROR')); 

Y := StrToInt (IniFile. ReadString (IniSampleSection, IniSampleY, 'ERROR')); 
end; 

finally 

IniFile. Free; 
end; 
end; 
end; 

procedure TfrmSampleLocator.btnSaveClick (Sender : TObject); 
var 

IniFile : TIniFile; 
begin 

ReferenceLocation := point (StrToInt (edRefX. Text) , StrToInt (edRefY. Text) ) ; 
SampleLocation := point (StrToInt (edSaropleX.Text) , StrToInt (edSampleY.Text) ) ; 

if FileExists (frmShadeAnalyzer .DiskDrive + 'Analyse\' + IniFileName) then 
begin 
try 

IniFile := TIniFile . Create (frmShadeAnalyzer . DiskDrive + 'AnalyseX' + 
IniFileName) ; 

with ReferenceLocation do 
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begin 

IniFile . WriteString (IniRef erenceSection, IniRefX, IntToStr (X) ) ; 
IniFile . WriteString (IniRef erenceSection, IniRef Y, IntToStr (Y) ) ; 
end; 

with SampleLocation do 
begin 

IniFile . WriteString ( IniSampleSection, IniSampleX, IntToStr (X) ) ; 
IniFile.WriteString(IniSampleSection,IniSarapleY, IntToStr (Y) ) ; 
end; 
finally 

IniFile. Free; 
end; 
end; 

Close; 
end; 

procedure TfrmSampleLocator.btnLoadSampleClick (Sender : TObject) ; 
begin 

OpenDialog. Title := 'Sample Imade To Display"; 

OpenDialog.InitialDir : = Copy (ParamStr (0) , 0, 3) + ' Analyse\Pictures\ ' 

OpenDialog. DefaultExt := GraphicExtension (TBitrtiap) ; 

OpenDialog. Filter := GraphicFilter (TBitmap) ; 

OpenDialog. Options := [of PathMustExist, ofFileMustExist] ; 

if OpenDialog. Execute then 

begin 

pmilmage . Picture . LoadFromFile (OpenDialog . Filename) ; 
end; 
end; 

procedure TfrmSampleLocator.praiImageClick( Sender: TObject); 
begin 

{ Check Location Option and Update The Location Co Ords } 

if rgLocation. Itemlndex = 0 then 

begin 

edRefX.Text := edXPos.Text; 

edRefY.Text := edYPos.Text; 
end 
else 
begin 

edSampleX.Text := edXPos.Text; 
edSampleY.Text := edYPos.Text; 
end; 
end; 

procedure Tf rmSampleLocator . FormSho'w (Sender : TObject); 
begin 

edRefX.Text := IntToStr (ReferenceLocation.x) ; 
edRefY.Text := IntToStr (ReferenceLocation.y) ; 
edSampleX.Text := IntToStr {SampleLocation. x) ; 
edSampleY.Text := IntToStr (SampleLocation. y) ; 
end; 

procedure Tf rmSampleLocator. btnCancelClick (Sender: TObject); 
begin 
Close; 
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end; 
end. 
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unit Sdimain; 



uses Windows, Classes^ Graphics, Forms, Controls, Menus, 
Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, 
ShadeData; 

const 

IniFilename = 'ShadeAnalyse.ini' ; 

IniReferenceSection = ' REFERENCE AREA' ; 
IniRefX = 'RefAreaX'; 

IniRefY = 'RefAreaY'; 

IniSampleSection = "SAMPLE AREA' ; 

IniSampleX = 'SampleAreaX' ; 

IniSampleY = 'SampleAreaY' ; 

IniShadeSetSection = 'DEFAULT GUIDE"; 
IniDefaultGuide = 'GuideFilename ' ; 

Startup : Boolean = true; // used for splash screen 
type 

TfrmShadeAnalyzer = class (TForm) 
SDIAppMenu: TMainMenu; 
FileMenu: TMenuItem; 
Exitltem: TMenuItem; 
Nl: TMenuItem; 
OpenDialog: TOpenDialog; 
Helpl: TMenuItem; 
Aboutl: TMenuItem; 
StatusBar: TStatusBar; 
Calibrate: TMenuItem; 
Optionsl: TMenuItem; 
Showlmagel: TMenuItem; 
ShowReferencel : TMenuItem; 
SetSampleLocl : TMenuItem; 
Analysel: TMenuItem; 
gbShadeSet : TGroupBox; 
btnLoad: TButton; 
btnSave: TButton; 
edShadeSetName: TEdit; 
gbSampleAnalysis: TGroupBox; 
btnMatch: TButton; 
Label 1: TLabel; 
edNearest: TEdit; 
SaveDialog: TSaveDialog; 
procedure ShowHint (Sender: TObject); 
procedure AboutlClick (Sender : TObject); 
procedure FormCreate (Sender: TObject); 
procedure CalibrateClick (Sender: TObject); 
procedure ShowImagelClick(Sender: TObject); 
procedure ShowReferencelClick (Sender: TObject); 
procedure SetSampleLoclClick (Sender : TObject); 
procedure AnalyselClick (Sender : TObject); 
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procedure btnSaveClick (Sender : TObject); 
procedure btnLoadClick (Sender : TObject); 

procedure FormClose (Sender : TObject; var Action: TCloseAction) ; 
procedure FormActivate (Sender : TObject); 
private 

{ Private declarations } 
Shades : TShadeRef erences; 

function Analyselmage (FileNaitie : string; ShadeName : string) : 
TShadeColours ; 

function FindNearestShade (Sample : tShadeColours) : string; 

procedure LoadShadeSet (Filename : string); 
public 

{ Public declarations ) 

DiskDrive : string; 

NewCalibration : boolean; 
end; 

var 

frmShadeAnalyzer : Tf rinShadeAnalyzer; 
implementation 
uses 

SysUtils, About, IniFiles, 

ToothObject, ImageDisplay, RefDisplay, SampleLocator, SplashScree 
($R *.DFM} 
const 

RefRedMedian = 0.5432; 
RefGreenMedian = 0.6308; 
RefBlueMedian = 0.3355; 

Re f Rows =1; 
Ref Columns = 1; 

SampleRows = GridHeight; // To change see Shade Data 
SampleColumns = GridWidth; 



procedure TfrmShadeAnalyzer.ShowHint (Sender: TObject); 
begin 

StatusBar. SimpleText := Application. Hint; 
end; 

procedure TfrmShadeAnalyzer.AboutlClick (Sender: TObject); 
begin 

AboutBox . ShowModal ; 
end; 

procedure TfrmShadeAnalyzer.FormCreate (Sender: TObject); 
var 

IniFile : TIniFile; 
DefaultShadeFilename : string; 
begin 

Application. OnHint := ShowHint; 
DiskDrive := Copy (ParamStr (0) , 0, 3) ; 

Shades := TShadeRef erences .Create; // we will build a new list 
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NewCalibration := false; 
try 

IniFile := TIniFile . Create (DiskDrive + 'AnalyseX' + IniFilename) ; 
DefaultShadeFilename := IniFile. ReadString (IniShadeSetSection, 
IniDef aultGuide, ' ERROR' ) ; 

DefaultShadeFilename := DiskDrive + 'Analyse\' + DefaultShadeFilename; 
LoadShadeSet (DefaultShadeFilename) ; 
finally 

IniFile. Free; 
end; 
end; 

'function Tf rmShadeAnalyzer .Analyselmage (FileName : string; ShadeName : string) : 
TShadeColours; 
var 

ShadeColours : TShadeColours; 
Tooth : TTooth; 
DeltaRed : real; 
DeltaGreen : real; 
DeltaBlue : real; 
PixelPercent : real; 
Re f Area : TRect; 
SampleArea : TRect; 
begin 

Tooth := TTooth. Create; 

{ Analyse The Reference Area } 

f rmlraageDisplay . HideGrid; 

Tooth . LoadBitmapFromFile ( FileName) ; 

frmlmageDisplay.pmi Image. Picture .Bitmap. As sign {Tooth. ToothBitmap) ; 
Application. ProcessMessages; 

RefArea := Tooth. FillSearchSampleLimits (frmSampleLocator.ReferenceLocation) ; 
frmlmageDisplay.DefineGrids (RefArea, RefRows, Ref Columns, Rect (0, 0, 0, 0) , 
SarapleRows, SampleColumns) ; 
Application . ProcessMessages ; 

Tooth. RemoveMask (Ref Area) ; 

frmlmageOisplay.pmilmage. Picture. Bitmap. Assign (Tooth. ToothBitmap) ; 
Application. ProcessMessages; 

Tooth. Analyse (0, 0, RefArea, RefRows, RefColumns, DeltaRed, DeltaGreen, 
DeltaBlue, PixelPercent); 

DeltaRed := RefRedMedian - DeltaRed; 
DeltaGreen := Ref GreenMedian - DeltaGreen; 
DeltaBlue := RefBlueMedian - DeltaBlue; 

{ Now Analyse the Sample Area } 

f rmlmageDisplay . HideGrid; 

Tooth. LoadBitmapFromFile (FileName) ; 

frmlmageOisplay.pmilmage . Picture. Bitmap. Assign (Tooth .ToothBitmap) ; 
Application. ProcessMessages; 

SampleArea := Tooth. FillSearchSampleLimits (f rmSampleLocator. SampleLocation) ; 
frmlmageDisplay. DefineGrids (Rect (0,0,0,0) , RefRows, RefColumns, SampleArea, 
SampleRows, SampleColumns) ; 
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Application. ProcessMessages; 

Tooth. RemoveRef lection (SampleArea) ; 
■ f rralmageDisplay . pmilmage . Picture . Bitmap . Assign (Tooth . Toot hBitmap ) ; 
Application. ProcessMessages ; 

ShadeColours := Tooth. AnalyseGrid{SampleArea, SampleRows, SampleColumns, 

DeltaRed, DeltaGreen, DeltaBlue) ; 

ShadeColours .Name := ShadeNarae; 
Result := ShadeColours; 
Tooth. Free; 
end; 

procedure TfrmShadeAnalyzer .CalibrateClick(Sender: TObject); 
var 

FilePath : string; 
Filelndex : integer; 
iFilename : string; 
ShadeName : string; 
ProgressBar : TProgressBar; 
ShadeColours : TShadeColours; 
begin 

OpenDialog. Title := 'Files To Analyse'; 

OpenDialog. InitialDir := DiskDrive + ' Analyse\Pictures\ ' ; 
OpenDialog. DefaultExt := GraphicExtension (TBitmap) ; 
OpenDialog. Filter := GraphicFilter (TBitmap) ; 

OpenDialog. Options := [of AllowMultiSelect, ofPathMustExist, of FileMustExist) ; 
if OpenDialog. Execute then 

with OpenDialog. Files do 

begin 

edShadeSetName.Text := 'New Calibration' ; 
NewCalibration := true; 

StatusBar. SimpleText := 'Loading Calibration Bitmaps'; 
Shades . Free; 

Shades := TShadeReferences .Create; // we will build a new list 

FilePath := ExtractFilePath (OpenDialog. FileName) ; 
ProgressBar := TProgressBar. Create (self ) ; 
ProgressBar. Parent := self; 
ProgressBar -Align := alBottom; 
ProgressBar. Min := 0; 
ProgressBar .Max := Count+2; 

ProgressBar. Step := 1; // the amount to move with the Stepit method 

for Filelndex := 0 to Count - 1 do 

begin 

IFileName := Strings [Filelndex] ; 

{ Get the Shade Name from the filename ) 
ShadeName := ExtractFilename (IFilename) ; 

StatusBar. SimpleText := 'Loading Calibration Bitmap : '+ShadeName; 
ShadeName := Uppercase (Copy (ShadeName, 1, Pos ( ' . ' , ShadeName) - 2)); // 
remove the letter 

ShadeColours := Analyselmage (IFileName, ShadeName); 

Shades . Adds ample (ShadeColours ) ; 
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ProgressBar.Stepit; // Move one Step amount 
end; 

Application . ProcessMessages ; 

{ Get the Shades into alphabetical order } 
StatusBar. SimpleText := 'Sorting Shade Samples'; 
Shades . SortList; 

ProgressBar.Stepit; // Move one Step amount 

{ Process the Shades Data to get average sets ) 

StatusBar . SimpleText := 'Reducing Shades to Reference Set'; 

Shades . ReduceList ; 

ProgressBar.Stepit; // Move one Step amount 

Shades . SortList ; 

ProgressBar . Free; 

StatusBar. SimpleText := 'Done'; 
end; 

end; 

procedure Tf rmShadeAnalyzer . ShowImagelClick (Sender : TObject); 
begin 

f rmlmageOisplay . Show; 
end; 

function Tf rmShadeAnalyzer . FindNearestShade (Sample : tShadeColours) : string; 
var 

CurrentShade ; TShadeColours; 
ShadeName : string; 
ShadeDif f erence : real; 
CurrentDif ference : real; 
Shadelndex : integer; 
begin 

ShadeDif ference := 1000000; 
ShadeName : = ' bJone ' ; 

for Shadelndex := 0 to Shades . ShadeList .Count - 1 do 
begin 

CurrentShade := Shades. ShadeList .Items [Shadelndex] ; 
CurrentDif ference := CurrentShade. ColourDif ference (Sample) ; 
if CurrentDif ference < ShadeDif ference then 
begin 

ShadeName := CurrentShade .Name; 
ShadeDif ference := CurrentDif ference; 
end; 
end; 

result := ShadeName; 
end; 

procedure TfrmShadeAnalyzer.ShowReferencelClick (Sender: TObject) ; 
begin 

f rmReferenceDisplay.LoadShades (Shades) ; 
f rmRef erenceDisplay . ShowModal; 
end; 
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procedure TfrmShadeAnalyzer.SetSampleLoclClick(Sender: TObject) ; 
begin 

frmSampleLocator.ShowModal; 
end; 

procedure TfrmShadeAnalyzer.AnalyselClick {Sender : TObject); 
var 

IFilename : string; 
SampleColours : TShadeColours; 
ProgressBar : TProgressBar; 
begin 

OpenDialog. Title := 'Files To Analyse'; 

OpenDialog. InitialDir := DiskDrive + ' Analyse\Pictures\ ' ; 

OpenDialog . DefaultExt := GraphicExtension (TBitmap) ; 

OpenDialog. Filter := GraphicFilter (TBitmap) ; 

OpenDialog. Options := [of PathMustExist, of FileMustExist] ; 

if OpenDialog. Execute then 

begin 

edNearest.Text := *'; 

StatusBar. SimpleText := 'Analyzing Sample'; 

ProgressBar := TProgressBar .Create (self ) ; 
ProgressBar. Parent := self; 
ProgressBar .Align := alBottom; 
ProgressBar .Min := 0; 
ProgressBar. Max := 3; 

ProgressBar. Step := 1; // the amount to move with the Stepit method 

IFilenarae := OpenDialog. Filename; 

ProgressBar. Stepit; 
Application. ProcessMessages; 

SampleColours := AnalyseImage(lFileName, 'Unknovm'); 

ProgressBar. Stepit; 
Application. ProcessMessages; 

StatusBar. SimpleText := 'Searching for Nearest Shade'; 
edNearest.Text := FindNearestShade (SampleColours) ; 

ProgressBar. Stepit; 
Application. ProcessMessages; 

StatusBar. SimpleText := 'Done'; 
ProgressBar. Free; 
end; 
end; 

procedure TfrmShadeAnalyzer.btnSaveClick(Sender: TObject); 
var 

IFilename : string; 
OutStream : TFileStream; 
IniFile : TIniFile; 
begin 

SaveDialog. Title := 'Shade Guide Filename to Save'; 
SaveDialog. InitialDir := DiskDrive + 'Analyse\'; 
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SaveDialog . DefaultExt := 'SDS'; 
SaveDialog. Filter := 'Shade Guides i *. SDS ' ; 
SaveDialog .Options := [of PathMustExist] ; 
if SaveDialog . Execute then 

with SaveDialog do 

begin 

if not FileExists (Filename) or 

(MessageDlg (Format ( 'Overwrite %s?' , [ExtractFilename (Filename) ] ) , 
mtConf irmation, [mbYes, mbNo] , 0) = mrYes) then 

begin 
try 

OutStream := TFileStream. Create (Filename, fmCreate or fmShareCompat) ; 
Shades. SaveToStream(OutStream) ; 

iFilename := ExtractFilename (SaveDialog. Filename) ; 
edShadeSetName.Text := copy (IFilename, 1, Length (IFilename) - 4); 
NewCalibration := falser- 
try 

IniFile := TIniFile. Create (DiskDrive + 'AnalyseX' + IniFilename) ; 
I^iFile.WriteString(IniShadeSetSection, IniDefaultGuide, IFilename) 
finally 

IniFile. Freer- 
end ; 
finally 

OutStream . Free ; 
end; 
end; 
end; 

end; 

procedure TfrmShadeAnalyzer.LoadShadeSet (Filename : string); 
var 

InStream : TFileStream; 
IniFile : TIniFile; 
IFilename : string; 
begin 
try 

edShadeSetName.Text := 'Loading. . . ' ; 

InStream := TFileStream. Create (Filename, fmOpenRead or fmShareCompat); 
Shades. Free; 

Shades := TShadeRef erences . Create; // we will build a new list 
Shades . LoadFroraStream ( InStream) ; 
IFilename := ExtractFilename (Filename) ; 

edShadeSetName.Text := copy (IFilename, 1, Length (IFilename) - 4); 
try 

IniFile := TIniFile . Create (DiskDrive + 'Analyse\' + IniFilename) ; 
IniFile. WriteString (IniShadeSetSection, IniDefaultGuide, IFilename) ; 
finally 

IniFile. Free; 
end; 
finally 

InStream. Free; 
end; 
end; 

procedure Tf rraShadeAnalyzer.btnLoadClick (Sender : TObject) ; 
begin 

OpenDialog. Title := 'Shade Guide Set to Load'; 
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OpenDialog. InitialDir := DiskDrive + 'Analyse\'; 
OpenDialog. DefaultExt := 'SDS'; 
OpenDialog. Filter := 'Shade Guides | *. SDS ' ; 

OpenDialog. Options ;= [of PathMustExist, ofFileMustExist] ; 
if OpenDialog. Execute then 

LoadShadeSet (OpenDialog. Filename) ; 

end; 

procedure TfrmShadeAnalyzer- FormClose (Sender: TObject; 

var Action: TCloseAction) ; 
begin 

{ Closing Program - Check for unsaved Calibration Set } 
if (NewCalibration) and 

(MessageDlg{ 'Calibration Load Not Saved. Save Now?', 

mtConfirmation, [mbYes, mbNo) , 0} = mrYes) then 
btnSaveClick(self) ; 

end; 

procedure TfrmShadeAnalyzer. FormActivate (Sender: TObject); 
begin 

if Startup then 
begin 

Startup := false; 

f rmSplashScreen . Show; 

Application. ProcessMessages; 

(SIFDEF SLIDELOGO} 

f rmSplashScreen. Timer 1. Interval := 1000; 
{$ELSE} 

f rmSplashScreen. Timer 1 .Interval := 3000; 
{$ENDIF} 

end; 
end; 

end. 
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unit ShadeData; 



The Shade reference is divided into a grid. Each area of the grid is 
analysed, and the average Red, Green and Blue values are stored. If there 
is an edge element in the sample, the valid flag is set to ignore the 
area in correlation matches. 



const 

GridWidth = 10; 
GridHeight = 10; 



type 

PShadeColourElement ^ 
TShadeColourElement ' 



''TShadeColourElement; 

class (TObject) 

Red : real4 8; // Average red content 

Green : real48; // Average green content 

Blue : real48; // Average blue content 
Valid : boolean; // Valid for comparison 

ValidPixel Percent : real48; // 0..1 (1 = all pixels 



TShadeColourElement) 



real48; 
: real48; 
real48; 



RedDev : 
GreenDev 
BIueDev 
RedMax : real48; 
RedMin : real48; 
GreenMax 
GreenMin 
BlueMax 



: real48; 
: real48; 
real48; 
BlueMin : real48; 
constructor Create; 

function ColourDif ference (ShadeColour : 
real48; 

procedure StoreColour (R, G, B 



real4 8; Percent 



procedure AddColour (R, G, B : real48; Percent : real); 
function ValidCell : boolean; 
procedure SaveToStream (OutStream : TStream) ; 
procedure LoadFromS t ream (InSt ream : TStream); 
private 

end; _ ■ 



// Name of the Shade reference 



PShadeColours = ''TShadeColours; - 
TShadeColours = class (TObject) 

Name : string; 
etc. 

GridColours : array [1. .GridWidth, 1 . .GridHeight] of 

TShadeColourElement; 

function ColourDif ference (ShadeColours : TShadeColours) 

real48; 

procedure SaveToStream (OutStream : TStream); 
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procedure LoadFromStream(InStreani : TStream) ; 
private 
end; 

TShadeReferences = class (TObject) 

ShadeList : TList; 
constructor Create; 

procedure AddSample (Sample : TShadeColours) ; 
procedure Clear; 
procedure SortList; 
procedure ReduceList; 

procedure SaveToStream {OutStream : TStream); 
procedure LoadFromStream(InStreara : TStream); 
private 
end; 

implementation 
uses 

SysUtils, Dialogs, Controls; 
const 

ValidityLimit = 0.95; // 95% of pixels must be used 



constructor TShadeColourElement .Create; 
begin 

Red := 0; 

Green := 0; 

Blue := 0; 

ValidPixelPercent := 0; 
Valid := false; 
RedDev := 0; 
GreenDev := 0; 
BlueDev := 0; 
RedMax := 0; 
RedMin := 1000; 
GreenMax ;= 0; 
GreenMin := 1000; 
BlueMax := 0; 
BlueMin := 1000; 
end; 

procedure TShadeColourEleraent.StoreColour (R,G,B : real48; Percent : real); 
begin 

Red := R; 

Green := G; 

Blue := B; 

ValidPixelPercent := Percent; 
Valid := (Percent >= ValidityLimit); 
end; 

procedure TShadeColourElement. AddColour(R,G,B : real48; Percent : real); 
begin 

if R > RedMax then RedMax := R; 

if G > GreenMax then GreenMax := G; 

if B > BlueMax then BlueMax := B; 



if R < RedMin then RedMin := R; 
if G < GreenMin then GreenMin := G; 
if B < BlueMin then BlueMin := B; 
Red := Red + R; 
Green := Green + G; 
Blue := Blue + B; 
end; 

function TShadeColourElement . ValidCell : boolean; 
begin 

Result := Valid; 
end; 

function TShadeColourElement .ColourDif ference (ShadeColour : TShadeColourElement) 

: real4 8; 

var 

DistanceRed : real48; 
DistanceGreen : real48; 
DistanceBlue : real48; 
begin 

if (Valid) and (ShadeColour .Valid) then 
begin 

DistanceRed:= (Red - ShadeColour . Red) ; 
DistanceGreen: = (Green - ShadeColour .Green) ; 
DistanceBlue:=(Blue - ShadeColour . Blue) ; 
Result := sqrt (sqr (DistanceRed) + 

sqr (DistanceGreen) + 

sqr (DistanceBlue) ) ; 

end 
else 

Result := -1; // cannot compare if any element is invalid 

end; 

procedure TShadeColourElement . SaveToStream(OutStream : TStream) ; 
begin 

OutStream.WriteBuffer (Red, SizeOf (Red) ) ; 
OutStream. WriteBuf f er (Green, SizeOf (Green) ) ; 
OutStreara.WriteBuffer (Blue, SizeOf (Blue) ) ; 
OutStream. WriteBuf fer (Valid, SizeOf (Valid) ) ; 

OutStream. WriteBuf fer (ValidPixelPercent, SizeOf (ValidPixelPercent) ) ; 
OutStream. WriteBuf fer{RedDev, SizeOf (RedDev) ) ; 
OutStream. WriteBuf fer (GreenDev, SizeOf (GreenDev) ) ; 
OutStream. WriteBuf fer(BlueDev, SizeOf (BlueDev) ) ; 
OutStream. WriteBuf fer(RedMax, SizeOf (RedMax) ) ; 
OutStream. WriteBuf fer (RedMin, SizeOf (RedMin) ) ; 
OutStreara.WriteBuffer (GreenMax, SizeOf (GreenMax) ) ; 
OutStreara.WriteBuffer (GreenMin, SizeOf (GreenMin) ) ; 
OutStreara.WriteBuffer (BlueMax, SizeOf (BlueMax) } ; 
OutStream. WriteBuf fer (BlueMin, SizeOf (BlueMin) ) ; 
end; 

procedure TShadeColourElement .LoadFromStream(InStream : TStream); 
begin 

InStream-ReadBuffer (Red, SizeOf (Red) ) ; 
InStream.ReadBuf fer (Green, SizeOf (Green) ) ; 
InStream.ReadBuf fer (Blue, SizeOf (Blue) ) ; 
InStream.ReadBuf fer (Valid, SizeOf (Valid) ) ; 



InStream.ReadBuf f er (ValidPixelPercent, SizeOf (ValidPixelPercent) ) ; 
InStream.ReadBuf fer (RedDev, SizeOf (RedDev) ) ; 
InStream.ReadBuf fer (GreenDev, SizeOf (GreenDev) ) ; 
InStream.ReadBuffer (BlueDev, SizeOf (BlueDev) ) ; 
InStream. ReadBuf f er {RedMax, SizeOf (RedMax) } ; 
InStream.ReadBuffer (RedMin, SizeOf (RedMin)); 
InStream.ReadBuf fer (GreenMax, SizeOf (GreenMax) ) ; 
InStream. ReadBuf fer (GreenMin, SizeOf (GreenMin) ) ; 
InStream.ReadBuffer (BlueMax, SizeOf (BlueMax) ) ; 
InStream. ReadBuf fer (BlueMin, SizeOf (BlueMin) ) ; 
-end; 

: function TShadeColours .ColourDif f erence (ShadeColours : TShadeColours) : 
" var 

Dif ferenceGrid : array [ 1 .. GridWidth, 1 . .GridHeight] of real48; 
Widthlndex : integer; 
Heightlndex : integer; 
MatchedCells : integer; 
begin 

Result := 0; 
MatchedCells := 0; 

{ Compare each grid positions colour } 
for Widthlndex := 1 to GridWidth do 

for Heightlndex := 1 to GridHeight do 

begin 

Dif ferenceGrid [Widthlndex, Heightlndex] := GridColours [Widthlndex 
Heightlndex] .ColourDif ference (ShadeColours .GridColours [Widthlndex, 
Heightlndex] ) ; 
end; 

{ 

Calculate the Colour Difference for the whole Shade 
initially just sum the differences 

Possibly just return the standard deviation or something. 

} 

for Widthlndex := 1 to GridWidth do 
for Heightlndex := 1 to GridHeight do 

if Dif ferenceGrid [Widthlndex, Heightlndex] <> -1 then 
begin 

Result := Result + Sqr (Dif ferenceGrid [Widthlndex, Heightlndex]) 
inc (MatchedCells) ; 
end; 

Result := Sqrt (Result /MatchedCells ) ; 
end; 

procedure TShadeColours. SaveToStream(OutStream : TStream) ; 
var 

Widthlndex : integer; 
Heightlndex : integer; 
StringLength : integer; 
begin 

StringLength := Length (Name) ; 

OutStreara.WriteBuffer (StringLength, SizeOf (StringLength) ) ; 
OutStream.WriteBuffer (Name [1] , StringLength) ; 
for VJidthlndex := 1 to GridWidth do 
for Heightlndex := 1 to GridHeight do 



GridColours [Widthlndex, Heightlndex] .SaveToStream (OutStream) ; 

end; 

procedure TShadeColours.LoadFromStreamdnStream : TStream) ; 
var 

Widthlndex : integer; 
Heightlndex : integer; 
StringLength : integer; 
begin 

InStream.ReadBuffer {StringLength, Si zeOf (StringLength) ) ; 
SetLength {Name, StringLength) ; 
InStream.ReadBuffer {Name [1] , StringLength) ; 
for Widthlndex := 1 to GridWidth do 

for Heightlndex := 1 to GridHeight do 

begin 

GridColours [Widthlndex, Heightlndex] := TShadeColourElement .Create; 
GridColours {Widthlndex, Heightlndex] .LoadFromStream(InStream) ; 
end; 

- end; 

procedure TShadeRef erences .AddSample (Sample : TShadeColours) ; 
begin 

ShadeList. Add (Sample) ; 
end; 

procedure TShadeReferences .Clear; 
begin 

ShadeList. Clear; 
end; 

constructor TShadeReferences . Create; 
begin 

ShadeList := TList .Create; 
end; 

function SortCompare (Iteral, Item2: pointer): Integer; 
begin 

if TShadeColours (Iteml) .Name < TShadeColours {ltera2) .Name then 
Result := -1 

else if TShadeColours (Iteml) .Name > TShadeColours (I tem2) .Name then 

Result := 1 
else 

Result := 0; 

end; 

procedure TShadeReferences, SortList; 

begin _ ■ 

ShadeList . Sort (SortCompare) ; 
end; 

procedure TShadeRe f erences . ReduceList ; 
var 

AverageShadeColours : TShadeColours; 
AveragedShades : TList; 
CurrentShade : TShadeColours; 
Shadelndex : integer; 
Row, Col : integer; 
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AverageCount : array (1 . .GridWidth, 1 . .GridHeight] of integer; 
begin 

{ For each individually Named shade, average all values into one ShadeColours 

} 

// New(AverageShadeColours) ; 
AveragedShades := TList .Create; 
//New (CurrentShade) ; 

CurrentShade := TShadeColours. Create; 
CurrentShade. Name := ''; 

for Shadelndex := 1 to ShadeList .Count do 
begin 

if CurrentShade. Name <> TShadeColours (ShadeList . Items [Shadelndex-l] ) .Name 

then 

begin 

if Shadelndex <> 1 then 
begin 

{ Save the last shade and start a new one } 
for Col := 1 to GridWidth do 
for Row := 1 to GridHeight do 

if AverageCount [Col, Row] <> 0 then 

with AverageShadeColours.GridColoursICol, Row) do 
begin 

Red := Red / AverageCount (Col, Row]; 
Green := Green / AverageCount [Col, Row]; 
Blue := Blue / AverageCount [Col, Row]; 

ValidPixelPercent := ValidPixelPercent / AverageCount [Col, Row]; 
end; 

AveragedShades. Add {AverageShadeColours) ; 
end; 

{This is a new Shade} 

AverageShadeColours := TShadeColours .Create; 
for Col := 1 to GridWidth do 

for Row := 1 to GridHeight do 

begin 

AverageShadeColours .GridColours {Col, Row] : = 
TShadeColourElement . Create; 

AverageCount (Col, Row] := 0; 
end; 

AverageShadeColours . Name : = TShadeColours (ShadeList . Items [Shadelndex- 
l]).Name; 
end; 

CurrentShade := ShadeList .Items [ShadeIndex-1] ; 

for Col := 1 to GridWidth do 
for Row := 1 to GridHeight do 
begin 

with AverageShadeColours. GridColours [Col, Row] do 
begin 

if CurrentShade. GridColours [Col, Row) .Valid then 
begin 

Valid := true; 
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AddColour (CurrentShade .GridColours (Col, Row] .Red, 

CurrentShade.GridColours [Col, Row] .Green, 
CurrentShade. GridColours (Col, Row] .Blue, 
CurrentShade. GridColours [Col, Row] . ValidPixelPercent) 
// ValidPixelPercent := ValidPixelPercent + 

CurrentShade. GridColours (Col, Row] .ValidPixelPercent; 
// Red := Red + CurrentShade .GridColours (Col, Row]. Red; 

// Green := Green + CurrentShade. GridColours [Col, Row] .Green; 

// Blue := Blue + CurrentShade. GridColours [Col, Row]. Blue; 

inc (AverageCount [Col, Row] ) ; 
end; 
end; 
end; 

end; 

( Save the last shade ) 
for Col := 1 to GridWidth do 
for Row := 1 to GridHeight do 

if AverageCount [Col, Row] <> 0 then 

with AverageShadeColours, GridColours (Col, Row] do 
begin 

Red := Red / AverageCount [Col, Row]; 
Green := Green / AverageCount [Col, Row]; 
Blue := Blue / AverageCount (Col, Row]; 

ValidPixelPercent := ValidPixelPercent / AverageCount [Col, Row]; 
end; 

AveragedShades . Add (AverageShadeColours) ; 

ShadeList . Free; 
ShadeList := AveragedShades; 
end; 

procedure TShadeReferences.SaveToStream{OutStream : TStream) ; 
var 

Shadelndex : integer; 
CurrentShade : TShadeColours; 
begin 

Shadelndex := ShadeList .Count; // First write the number of Shade in the 
OutStream.WriteBuffer (Shadelndex, SizeOf (Shadelndex) ) ; 
for Shadelndex := 0 to ShadeList .Count - 1 do 
begin 

CurrentShade := ShadeList. Items (Shadelndex] ; 
CurrentShade. SaveToStream(OutStream) ; 
end; 
end; 

procedure TShadeReferences .LoadFromStreain(InStream : TStream); 
var 

NumberOfShades : integer; 
Shadelndex : integer; 
CurrentShade : TShadeColours; 
begin 

InStream.ReadBuffer (NumberOfShades, SizeOf (NumberOfShades] ) ; 

for Shadelndex := 0 to NumberOfShades - 1 do 

begin 

CurrentShade := TShadeColours .Create; 
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CurrentShade . LoadFromSt ream ( InSt ream) ; 
AddSample (CurrentShade) ; 
end; 
end; 

end. 
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unit SplashScreen; 



interface 
uses 

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
ExtCtrls, TMultiP; 

type 

TSplashState = (splCenter, splMoving, splDone) ; 

TfrmSplashScreen = class (TFcrm) 
Timerl: TTimer; 
e pnlLogo: TPanel; 
C Imagel: TImage; 

H procedure Timer ITimer (Sender : TObject); 
jlii procedure FormCreate (Sender : TObject); 
fZ\ procedure FormPaint (Sender : TObject); 
ifi private 

jii { Private declarations } 

SplashState : TSplashState; 
L, StartPosition : TPoint; 

StartSize : TPoint; 
/^"! VirticalStep : integer; 
'j- HorizontalStep : integer; 
D WidthStep : integer; 
G HeightStep : integer; 

CanPaint : boolean; 
public 

{ Public declarations } 
end; 

var 

f rmSplashScreen : TfrmSplashScreen; 
implementation 
{$R *.DFM) 
const 

FinishPosition : TPoint = {x:580; y:700); 
FinishSize : TPoint = (x:430; y:50); 

Duration = 2000; // ms 

Movelnterval = 50; // ms 

procedure Tf rmSplashScreen, TimerlTimer (Sender : TObject); 

begin _ ■ 

{$IFDEF SLIDELOGO} 

if abs (FinishPosition. X - Left) < abs (HorizontalStep) then 
HorizontalStep := HorizontalStep div abs (HorizontalStep) ; 
if abs (FinishPosition. Y - Top) < abs (VirticalStep) then 
VirticalStep := VirticalStep div abs (VirticalStep) ; 

if abs (FinishSize. X - Width) < abs (WidthStep) then 

WidthStep := WidthStep div abs (WidthStep) ; 
if abs (FinishSize. Y - Height) < abs (HeightStep) then 
HeightStep := HeightStep div abs (HeightStep) ; 



SplashScreen - page 1 



CanPaint := false; 



case SplashState of 
splCenter: 
begin 

Timerl . Interval := Movelnterval; 

SplashState := splMoving; 
end; 
splMoving: 
begin 

if (Top = FinishPosition.y) and (Left = FinishPosition.x) and 
(Height = FinishSize .y) and (Width = FinishSize.x) then 
SplashState := splDone 
else 
begin 

if Top <> FinishPosition.y then 

Top := Top + VirticalStep; 
if Left <> FinishPosition.x then 

Left := Left + HorizontalStep; 
if Height <> FinishSize. y then 

Height := Height + HeightStep; 
if Width <> FinishSize.x then 

Width := Width + WidthStep; 

end; 
end; 
splDone: 
begin 

Timerl .Enabled := false; 
end; 

end; 

CanPaint := true; 
{$ELSE} 

Height := FinishSize. y; 

Width := FinishSize.x; 

Top := FinishPosition.y; 

Left := FinishPosition.x; 

pnlLogo.BevelWidth := 2; 
{$ENDIF} 
end; 

procedure Tf rmSplashScreen. FormCreate (Sender: TObject); 
begin 

SplashState := splCenter; 

StartPosition.x := Left; 

StartPosition.y := Top; 

StartSize.x := Width; 

StartSize.y := Height; 
//VirticalStep := (FinishPosition.y - StartPosition.y) div (Duration div 
Movelnterval) ; 

//HorizontalStep := (FinishPosition.x - StartPosition.x) div (Duration div 
Movelnterval) ; 

//HeightStep := (FinishSize. y - StartSize.y) div (Duration div Movelnterval); 
//WidthStep := (FinishSize.x - StartSize.x) div (Duration div Movelnterval); 

VirticalStep := 1; 

HorizontalStep := 1; 

HeightStep := -1; 
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WidthStep := -1; 
CanPaint := true; 
end; 

procedure TfrmSplashScreen. FormPaint (Sender : TObject) 
begin 

if CanPaint then 
Imagel . Repaint ; 

end; 
end- 
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unit ToothObject; 



interface 



uses 

Windows, SysUtils, Classes, Graphics, 
ShadeData; 

type 

TTooth = class (TObject) 
private 

Ref erencelnitialised : boolean; 

function CalculateTestArea (Row, Col : integer; 

Area : TRect; 

NoRows, NoCols : integer) : TRect; 

public 

Red : real; 
Green : real; 
Blue : real; 
Hue : real; 
Saturation : real; 
Intensity : real; 
Ref Red : real; 
RefGreen : real; 
Ref Blue : real; 
Ref Hue : real; 
RefSaturation : real; 
Reflntensity : real; 
ToothBitmap : TBitmap; 
ToothBitmapMask : TBitmap; 
constructor Create; 
procedure Free; 

procedure LoadBitmapFromFile (Filename : String); 
procedure RemoveRef lection (TestArea : TRect); 
procedure RemoveMask (TestArea : TRect); 

function FillSearchSampleLimits (StartPoint : TPoint) : TRect; ■ 
procedure Analyse (Row, Col : integer; 

Area : TRect; NoRows, NoCols : integer; 

var R, G, B : real; 

var PixelPercentage : real); 
function AnalyseGrid(Area : TRect ; NoRows , NoCols : integer; 

DeltaRed, DeltaGreen, DeltaBlue : real) : 

TShadeColours; 

procedure CalculateHSI (R, G, B : real; var Hue, Sat, Int : real); 

end; 



implementation 

uses 

Dialogs, Math; 

const 

RedMask : longint = $0O0O00FF; 

GreenMask : longint = $OO00FFO0; 
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BlueMask : longint = $O0FFO000; 



Boundrylntensity = 0.58; // sum of RGB 

Reflectionlntensity = 1.8 6; 

type 

TDirection = (Up, Down, Left, Right); 

constructor TTooth .Create; 
begin 

ToothBitmap := TBitraap. Create; 
ToothBitmap. Width := 640; 
ToothBitmap. Height := 480; 
ToothBitmapMask := TBitmap. Create; 
ToothBitmapMask. Width := 640; 
ToothBitmapMask. Height := 480; 
Referencelnitialised := false; 

end; 

procedure TTooth. Free; 
begin 

ToothBitmap . Free ; 

ToothBitmapMask. Free; 

Inherited Free; 
end; 

function TTooth. FillSearchSampleLimits (StartPoint : TPoint) : TRect; 
procedure FillSearch (StartpointX, StartpointY : integer); 
var 

Red, Green, Blue : integer; 
X, y : integer; 
begin 

if StartPointX > Result. Right then 

Result. Right := StartpointX; 
if StartpointX < Result. Left then < 

Result. Left := StartpointX; 
if StartpointY > Result. Bottom then 

Result .Bottom := StartpointY; 
if StartpointY < Result. Top then 

Result. Top := StartpointY; 

for X := -1 to 1 do 
for y := -1 to 1 do 

if (StartpointX+x < 640) and (StartpointX+x > 0) and 
(StartpointY+y < 480) and (StartpointY+y > 0) and 

(ToothBitmapMask. Canvas. Pixels[StartpointX+x, StartpointY+y] <> 0) 

then 

begin 

Red := ToothBitmap. Canvas . Pixels [StartpointX+x, StartpointY+y] and 

RedMask; 

Green := (ToothBitmap. Canvas. Pixels [StartpointX+x, StartpointY+y] and 
GreenMask) shr 8; 

Blue := (ToothBitmap. Canvas. Pixels (StartpointX+x, StartpointY+y] and 
BlueMask) shr 16; 

if {(Red + Green + Blue)/255) > Boundrylntensity then 
begin 

ToothBitmapMask. Canvas. Pixels [StartpointX+x, StartpointY+y] := 0; 
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FillSearch (StartpointX+x, StartpointY+y) ; 
end 
end; 

end; 
begin 

Result := Rect(640, 480, 0, 0); 
FillSearch (StartPoint.X, StartPoint . Y) ; 
end; 

function TTooth.CalculateTestArea (Row, Col : integer; 

Area : TRect ; 

NoRows, NoCols : integer) : TRect; 

var 

TestArea : TRect; 
ColSpacing : real; 
RowSpacing : real; 
begin 

with Area do 
begin 

ColSpacing := (Right - Left) / NoCols; 
RowSpacing := (Bottom - Top) / NoRows; 
TestArea. Top := Top + Trunc (RowSpacing * Row); 
TestArea. Bottom := Top + Trunc (RowSpacing * (Row + 1)); 
TestArea .Left := Left + Trunc (ColSpacing * Col); 
TestArea. Right := Left + Trunc (ColSpacing * (Col + 1)); 
end; 

CalculateTestArea := TestArea; 
end; // CalculateTestArea 

procedure TTooth . RemoveRef lection (TestArea : TRect); 
var 

i : integer; 
j : integer; 

Red, Green, Blue : integer; 
begin 

with TestArea do 

for i := Left to Right do 

for j := Top to Bottom do 
begin 

if (ToothBitMapMask. Canvas. Pixels {i,j] <> 0) then 

ToothBitMap. Canvas. Pixels[i,jl := 0 
else 
begin 

Red := ToothBitMap . Canvas . Pixels [i, j ] and RedMask; 

Green := (ToothBitMap. Canvas. Pixels [i, j } and GreenMask) shr 

Blue := ( ToothBitMap. Canvas. Pixels [i,j] and BlueMask) shr H 

if ( (Red + Green + Blue) / 255 > Ref lectionlntensity) then 
ToothBitMap. Canvas. Pixels[i,j] := 0; 

end; 

end; 



end; // RemoveRef lection 

procedure TTooth. RemoveMask (TestArea : TRect); 
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i : integer; 
j : integer; 
begin 

with TestArea do 

for i := Left to Right do 

for j := Top to Bottom do 

if (ToothBitMapMask. Canvas. Pixels [i,j] <> 0) then 
ToothBitMap.Canvas. Pixels := 0; 



end; // RemoveRef lection 



procedure TTooth. Analyse (Row, Col : integer; 

Area : TRect; NoRows, NoCols : integer; 

var R, G, B : real; 

var PixelPercentage : real); 

var 

TestArea : TRect; 
PixelCount : longint; 

i : integer; 
j : integer; 
RedTotal : longint; 
GreenTotal : longint; 
BlueTotal : longint; 
Red, Green, Blue : integer; 
begin 

TestArea := CalculateTestArea (Row, Col, Area, NoRows, NoCols) ; 
with TestArea do 

PixelCount := (Right - Left + 1) * (Bottom - Top + 1); 

// Now average ignoring reflections and blemishes 
RedTotal := 0; 
GreenTotal := 0; 
BlueTotal := 0; 



with TestArea do 

for i := Left to Right do 

for j := Top to Bottom do 

begin 

if ToothBitMap. Canvas. Pixels [i,j] <> 0 then 
begin 

Red := ToothBitMap.Canvas . Pixels [i, j ] and RedMask; 

Green := (ToothBitMap.Canvas . Pixels [i, j ] and GreenMask) shr 8 

Blue := (ToothBitMap.Canvas . Pixels [i, j ] and BlueMask) shr 16; 

RedTotal := RedTotal + Red; 

GreenTotal := GreenTotal + Green; 

BlueTotal := BlueTotal + Blue; 
end 
else 
begin 

PixelCount := PixelCount - 1; // Ignored this pixel 

end; 
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// Normalised RGB 
if PixelCount > 0 then 
begin 

RedTotal / PixelCount / 255; 
GreenTotal / PixelCount / 255; 
BlueTotal / PixelCount / 255; 
with TestArea do 

PixeiPercentage := PixelCount / ( (Bottom-Top+1) * {Right - Left+1) } ; 

end 
else 
begin 
R := 0; 
0; 
0; 

PixeiPercentage := 0; 
end; 

end; // Analyse 

function TTooth. Anal yseGrid (Area : TRect; 

NoRows, NoCols : integer; 

DeltaRed, DeltaGreen, DeltaBlue : real) : 

TShadeColours; 
var 

Row, Col : integer; 

Red, Green, Blue, PixelPercent : real; 
begin 

Result := TShadeColours .Create; 

for Row := 0 to NoRows - 1 do 
for Col := 0 to NoCols - 1 do 
begin 

Analyse (Row, Col, Area, NoRows, NoCols, 

Red, Green, Blue, PixelPercent); 
Result. GridColours [Col+1, Row+1] := TShadeColourElement. Create; 
Result .GridColours [Col+1, Row+1] .StoreColour (Red + DeltaRed, 

Green + DeltaGreen, 



end; 

end; 



Blue + DeltaBlue, 
PixelPercent) ; 



procedure TTooth. CalculateHSI(R, G, B : real; var Hue, Sat, Int : real); 

function Minimum (vl, v2, v3 : real) : real; 
begin 

if (vl <= v2) and (vl <= v3) then 
minimum := vl 

else 

if (v2 <= vl) and (v2 <= v3) then 
Minimum := v2 
else 

Minimum := v3; 

end; 

function Maximum (vl, v2, v3 : real) : real; 
begin 

if (vl >= v2) and (vl >= v3) then 
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Maximum := vl 

else 

if (v2 >= vl) and (v2 >= v3) then 
Maximum := v2 
else 

Maximum := v3; 

end; 
begin 

// Calculation using Gonzalez and Woods 
Int := (R + G + B) / 3; 

if Int > 0 then 
begin 

Sat := 1 - (3 / (R + G + B)) * Minimum (R, G, B) ; 

Hue := arccos(({(R-G)+(R-B))/2)/sqrt{sqr(R-G)+{(R-B)*(G-B)))) /(2*pi) 
if (B / Int) > (G / Int) then 
Hue := 1 - Hue; 

end 
else 
begin 

Sat := 0; 

Hue := 0; 
end; 

end; // CalculateHSI 

procedure TTooth. LoadBitmapFromFile (Filename : String); 
begin 

ToothBitmap.LoadFromFile (Filename) ; 
ToothBitmap. Dormant; 

ToothBitmapMask. Assign (ToothBitmap) ; 
end; // LoadBitmapFromFile 



end. 
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